CD Schooolhouse Version 10.0/CD Schooolhouse Version 10.0.ISO/pc/dos/misc/mvsp13/reformat.pas

Pascal/Delphi Source File | 1994-03-03 | 15.9 KB | 551 lines

PROGRAM reformat;
{$R+}
{
                            REFORMAT
        (C) Copyright - Warren L. Kovach      - Feb., 1986
                        Department of Biology
                        Indiana University
                        Bloomington, IN  47405

  Converts data matrix from normal form, with species as rows and
  samples as columns, to condensed format used by Hill's DECORANA
  program.  This condensed format consists of data ponts entered
  as couplets consisting of the number for the species and the
  abundance.  Each line of the file begins with the number of the
  sample, followed by the couplets.  The data for a sample may
  continue onto other lines.

  See the user's manuals for MVSP and DECORANA for details on the
  structure of the data files.

  MVSP is a multivariate statistical package available from the
  author of this utility.

  DECORANA is a detrended correspondance analysis program,
  written by M.O. Hill and distributed for mainframe computers by
  Hugh G. Gauch (Ecology and Systematics, Cornell University,
  Ithica, NY  14850).  This program was modified for the IBM PC
  by Christopher Clampitt (Department of Botany, University of
  Washington, Seattle, WA 98195).

  This program program may be freely copied and distributed, as
  long as no price is charged for it, other than the price of the
  media (not to exceed $5).  Any bugs or suggestions should be
  reported to me at the address given above.

  - Warren L. Kovach
}
{$I-}  { turn off Turbo I/O error checking, use IOCHECK instead }

CONST
  maxdim = 95;
  bell   = #07;
  cr     = #13;
  space  = #32;
  ioval  : integer = 0;
  ioerr  : boolean = false;
TYPE
  two_d_array_type = array[1..maxdim,1..maxdim] of real;
  name_lab         = string[8];
  name_array       = array[1..maxdim] of name_lab;
  long_string      = string[70];
VAR
  data            : two_d_array_type;
  col_lab,row_lab : name_array;
  in_label        : name_lab;
  title,
  infilename,
  outfilename     : long_string;
  i,j,
  columns,rows    : integer;
  labels_present  : boolean;
  datin           : real;
  infile,outfile  : text [$800];  { use 2K buffer }
  marker,labels   : char;

{ ****************************************************************** }

PROCEDURE syntax;
BEGIN
  writeln(bell);
  writeln('Filenames must be specified on the DOS command line.');
  writeln;
  writeln('Command syntax is "REFORMAT infilename [outfilename]".');
  writeln('  If "outfilename" is omitted, outfile defaults to "infilename.RFM"');
END;

{ ****************************************************************** }

PROCEDURE IOCheck;
{    Checks for I/O errors through the TURBO procedure IOresult,
     & then prints out an appropriate message before aborting.  }
VAR
  Ch                   : Char;
BEGIN
  IOVal := IOresult;
  IOErr := (IOVal <> 0);
  if IOErr then begin
    normvideo;
    Write(bell);
    writeln;
    case IOVal of
      $01 : Write('File does not exist');
      $02 : Write('File not open for input');
      $03 : Write('File not open for output');
      $04 : Write('File not open');
      $05 : Write('Can''t read from this file');
      $06 : Write('Can''t write to this file');
      $08 : Write('Disk write error, disk may be full');
      $09 : Write('Illegal character input; check data file');
      $10 : Write('Error in numeric format; check data file');
      $99 : Write('Unexpected end of file');
      $F0 : Write('Disk write error, disk may be full');
      $F1 : Write('Directory is full');
      $F3,$243 : Write
   ('Not enough file handles; put "FILES=16" in CONFIG.SYS and reboot');
      $FF : Write
   ('File has disappeared; make sure disk was not changed');
    else      Write('Unknown I/O error:  ',IOVal:3);
    end;
    writeln;
    writeln('Aborting..');
    lowvideo;
    close(infile);IOCHECK;close(outfile);IOCHECK;
    HALT;
  end;
END; { of proc IOCheck }

{ ****************************************************************** }

PROCEDURE yesno(VAR answer:boolean);
{ Gets character input from user and checks to make sure it is
  a 'Y' or 'N' for yes or no.  }
VAR
  input  :char;
{-------------------------------------------------------------------}
  PROCEDURE rvsvideo;
  BEGIN
    textcolor(black);
    textbackground(lightgray);
  END;  { procedure rvsvideo }
{-------------------------------------------------------------------}
BEGIN { procedure yesno }
  repeat
    rvsvideo;
    write('Y');
    lowvideo;
    gotoxy(wherex-1,wherey);
    read (kbd,input);
    input := upcase(input);
    if not (input in ['Y','N',cr]) then write(bell);
  until (input in ['Y','N',cr]);
  answer := input in ['Y',cr];
  if input = cr then input:='Y';
  writeln(input);
  writeln;
END;

{ ****************************************************************** }

FUNCTION uppercase(str:long_string):long_string;
  { converts a string to uppercase }
VAR
  i       : integer;
  new_str : long_string;
BEGIN
  new_str := '';
  for i := 1 to length(str) do
    new_str := new_str + upcase(str[i]);
  uppercase := new_str;
END;

{ ****************************************************************** }

PROCEDURE openfiles;
VAR
  len                    : integer;
  fileexist,confirm      : boolean;
{-------------------------------------------------------------------}
FUNCTION exist(filename:long_string):boolean;
VAR
  fil : file;
BEGIN
  assign(fil,filename);
  reset(fil);
  exist := (ioresult = 0);
  {$i+}
  close(fil);
  {$I-}
END;
{-------------------------------------------------------------------}
BEGIN { openfiles }
{ get filenames from command line parameters }
  infilename := UPPERCASE(paramstr(1));
  outfilename := UPPERCASE(paramstr(2));

{ if no output filename given, create one with extension '.RFM' }
  if paramstr(2) = '' then begin
    len := pos('.',infilename);
    if len = 0 then len := length(infilename)+1;    { len=0 if no '.' found }
    outfilename := concat(copy(infilename,1,len-1),'.RFM');
  end;

{ check for existence of input file }
  fileexist := exist(infilename);
  if not fileexist then begin
    writeln(bell);
    normvideo;
    writeln('File not found, try again');
    lowvideo;
    halt;
  end;

{ warn user if output file already exists }
  fileexist := exist(outfilename);
  if fileexist then begin
    normvideo;
    writeln(bell);
    write('File "',outfilename,'" already exists; overwrite? ');
    lowvideo;
    YESNO(confirm);
    if not confirm then halt;
  end;

{ open files }
  assign(infile,infilename);
  reset(infile);IOCHECK;
  assign(outfile,outfilename);
  rewrite(outfile);IOCHECK;
END; { openfiles }

{ ****************************************************************** }

PROCEDURE check_for_eof;
  { Check for end of file while reading data }
BEGIN
  if eof(infile) then begin
    normvideo;
    writeln(bell);
    write('Not enough data in file.');
    close(infile);IOCHECK;
    close(outfile);IOCHECK;
    writeln;writeln;
    write('ABORTING...');
    lowvideo;
    halt;
  end;
END;

{ ****************************************************************** }

PROCEDURE parse_label (VAR lab : name_lab);
  { reads labels from the input file.  Labels must be
    separated by spaces or end of line }
VAR
  word_found : boolean;
  end_word   : boolean;
  ch         : char;
BEGIN
  lab := '';
  word_found := false;
  end_word := false;
  repeat
    read(infile,ch);IOCHECK;
    CHECK_FOR_EOF;
    if ch > space then begin
      word_found := true;
      lab := concat(lab,ch);
    end;
    if ((ch = space) or (ch = cr)) and word_found then
      end_word := true;
  until word_found and end_word;
END;

{ ****************************************************************** }

PROCEDURE read_mvsp;
       { read data from input file }
BEGIN
{ read header }
  readln(infile,marker,labels,rows,columns,title);IOCHECK;
  if upcase(labels) = 'L' then labels_present := true
    else labels_present := false;

{ read column labels }
  if labels_present then begin
    for i := 1 to columns do  begin
      PARSE_LABEL(in_label);
      col_lab[i] := in_label;
    end;
    columns := columns + 1;      { one extra column for row labels }
  end;

{ read data }
  for i:=1 to rows do begin
    for j:=1 to columns do begin
      CHECK_FOR_EOF;
      if (labels_present) and (j = 1) then begin  { read row labels }
        PARSE_LABEL(in_label);
        row_lab[i] := in_label;
      end
      else begin
        read (infile,datin);IOCHECK;              { read data points }
        if labels_present then data[i,j-1]:=datin
          else data[i,j] := datin;
      end;
    end; { for j }
    if labels_present then begin
      readln(infile);IOCHECK;
    end;
  end; { for i }
  if labels_present then columns := columns - 1;
  reset(infile);  { reset so EOF is false on subsequent IOCHECK's}
  IOCHECK;
END;

{ ****************************************************************** }

PROCEDURE read_decorana;

VAR
  transform1         : real;
  couplets_per_line,
  species,sample     : integer;
  format             : long_string;

BEGIN
{ initialize variables }
  rows := 0;
  columns := 0;
  sample := -1;

{ read parameters }
  readln(infile,transform1);IOCHECK;
  if transform1 <> -1 then begin    { skip transformation statements }
    for i := 1 to 9 do begin
      readln(infile);IOCHECK;
    end;
  end;
  readln(infile);IOCHECK;        { skip operating parameters }
  readln(infile,title);IOCHECK;  { read title }
  readln(infile,format);IOCHECK; { read format statement }
  couplets_per_line := ((ord(format[69])-48) * 10) + (ord(format[70])-48);

{ read data }
{ Note that data points must be separated by at least one space }

  while sample <> 0 do begin
    read(infile,sample);IOCHECK;
    CHECK_FOR_EOF;
    if sample > columns then columns := sample;
    for i := 1 to couplets_per_line do begin
      if not eoln(infile) then begin
        read(infile,species,datin);IOCHECK;
        CHECK_FOR_EOF;
        data[sample,species] := datin;
        if species > rows then rows := species;
      end;
    end;
    readln(infile);IOCHECK;
  end; { while }

{ read labels }
  for i := 1 to rows do begin
    read(infile,in_label);IOCHECK;
    CHECK_FOR_EOF;
    row_lab[i] := in_label;
    if (i mod 10 = 0) or (i = rows) then begin
      readln(infile);IOCHECK;
    end;
  end;
  for i := 1 to columns do begin
    read(infile,in_label);IOCHECK;
    CHECK_FOR_EOF;
    col_lab[i] := in_label;
    if (i mod 10 = 0) or (i = columns) then begin
      readln(infile);IOCHECK;
    end;
  end;
  reset(infile); { reset so EOF is false on subsequent IOCHECK's}
  IOCHECK;
END;

{ ****************************************************************** }

PROCEDURE write_decorana;
TYPE
  const_array = array[1..10] of string[16];
CONST
  octave_transform : const_array = ('     .25      1.','     .75      2.',
                                    '    1.50      3.','    3.00      4.',
                                    '    6.00      5.','   12.00      6.',
                                    '   24.00      7.','   48.00      8.',
                                    '   82.00      9.','   -1.00      0.');
  options = '    0    0    0    0';
  format =
  '(I2,1X,6(I3,F9.2))                                                  06';
  no_omitted_samples1 = '    0';
  no_omitted_samples2 = '   0';
VAR
  number_written : integer;
  octave_trans   : boolean;
BEGIN
  writeln;write('Set up DECORANA file for octave transformation? ');
  YESNO(octave_trans);
  write('Processing: ',infilename,' => ',outfilename,'...');

{ write out option parameters }
  if octave_trans then for i := 1 to 10 do begin
    writeln(outfile,octave_transform[i]);IOCHECK;
  end
  else begin
    writeln(outfile,octave_transform[10]);IOCHECK;
  end;
  writeln(outfile,options);IOCHECK;
  writeln(outfile,title);IOCHECK;
  writeln(outfile,format);IOCHECK;

{ write out data }
  for j := 1 to columns do begin
    number_written := 0;
    for i := 1 to rows do begin
      if data[i,j] <> 0 then begin          { write out non-zero data }
        if number_written = 0 then begin
          write(outfile,j:2,' ');IOCHECK;   { write out sample number }
        end;
        write(outfile,i:3,data[i,j]:9:2);IOCHECK; { write out species couplet }
        number_written := number_written + 1;
        if number_written = 6 then begin          { 6 couplets per line }
          writeln(outfile);IOCHECK;
          number_written := 0;
        end;
      end;
    end; { for i }
    if number_written <> 0 then begin
      writeln(outfile);IOCHECK;
    end;
  end;   { for j }
  writeln(outfile,'00');     { end of data }
  IOCHECK;

{ write out labels }
  if labels_present then begin
    for i := 1 to rows do begin
      write(outfile,row_lab[i]:8);IOCHECK;
      if (i mod 10 = 0) or (i = rows) then begin  { 10 labels per line }
        writeln(outfile);IOCHECK;
      end;
    end;
    for i := 1 to columns do begin
      write(outfile,col_lab[i]:8);IOCHECK;
      if (i mod 10 = 0) or (i = columns) then begin  { 10 labels per line }
        writeln(outfile);IOCHECK;
      end;
    end;
  end
  else begin        { leave blank lines if no labels }
    writeln(outfile);IOCHECK;
    for i := 1 to rows do
      if i mod 10 = 0 then begin
        writeln(outfile);IOCHECK;
      end;
    writeln(outfile);IOCHECK;
    for i := 1 to columns do
      if i mod 10 = 0 then begin
        writeln(outfile);IOCHECK;
      end;
  end;
  writeln(outfile,no_omitted_samples1);IOCHECK;
  writeln(outfile,no_omitted_samples2);IOCHECK;
END;

{ ****************************************************************** }

PROCEDURE write_mvsp;

VAR
  printwidth : integer;

BEGIN
  writeln;write('Processing: ',infilename,' => ',outfilename,'...');

{ write out header }
  labels_present := false;
  for i := 1 to 8 do
    if col_lab[1][i] > space then labels_present := true;
  if labels_present then begin
    write(outfile,'*L ');IOCHECK;
    printwidth := 7;
  end
  else begin
    write(outfile,'* ');IOCHECK;
    printwidth := 8;
  end;
  writeln(outfile,rows,' ',columns,' ',title);IOCHECK;

{ write out column labels }
  if labels_present then begin
    for i := 1 to columns do begin
      write(outfile,col_lab[i],' ');IOCHECK;
      if i mod printwidth = 0 then begin
        writeln(outfile);IOCHECK;
      end;
    end;
    writeln(outfile);IOCHECK;
  end;

{ write out row labels & data }
  for i := 1 to rows do begin
    for j := 1 to columns do begin
      if (labels_present) and (j = 1) then begin
        write(outfile,row_lab[i],' ');IOCHECK;
      end;
      write(outfile,data[j,i]:8:2,' ');IOCHECK;
      if j mod printwidth = 0 then begin
        writeln(outfile);IOCHECK;
      end;
    end;
    writeln(outfile);IOCHECK;
  end;
END;

{ ****************************************************************** }

BEGIN                   { main handling routine }
{ initialize variables }
  fillchar(data,sizeof(data),0);
  fillchar(col_lab,sizeof(col_lab),' ');
  fillchar(row_lab,sizeof(col_lab),' ');

  lowvideo;
  writeln;
  writeln('REFORMAT - Converts data files between MVSP and DECORANA formats');
  writeln('    (C) Copyright - Warren L. Kovach - Feb., 1986');
  writeln;
  if (paramstr(1) = '') then begin
    SYNTAX;        { give the user some help }
    halt;
  end;
  OPENFILES;

{ read file header }
  read(infile,marker);IOCHECK;
  reset(infile);IOCHECK;

{ process file }
  if marker = '*' then begin
    writeln;writeln('Converting from MVSP to DECORANA format');
    READ_MVSP;
    WRITE_DECORANA;
  end
  else begin
    writeln;writeln('Converting from DECORANA to MVSP format');
    READ_DECORANA;
    WRITE_MVSP;
  end;

  close(infile);IOCHECK;
  close(outfile);IOCHECK;
  writeln('Done');
  {$I+}
END.